home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / SM / SM-Test.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  9.3 KB  |  217 lines  |  [TEXT/MACA]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;
  3. ; File:         SM-TEST.LISP
  4. ; Author:       Dan Suthers
  5. ; Created:      04-Jun-88 13:33:02
  6. ; Modified:     22-Jun-90 02:13:54 (Dan Suthers)
  7. ; Language:     LISP
  8. ; Package:      USER
  9. ;
  10. ; Description:  For testing SM.LISP when it is changed.  One should load
  11. ;               this file after loading SM and check the printed results.
  12. ;               Do it for both uncompiled and compiled versions of this
  13. ;               file, in SEPARATE lisp sessions.
  14. ;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16.  
  17. (in-package :user)
  18.  
  19. (require :SM)
  20.  
  21. (setf *print-pretty* t)
  22.  
  23. (format T "~%~%---------- STRUCTURE TYPE DEFINITION TESTS ----------")
  24. (format T "~%Creating a test structure with:
  25. (sm:dst (test (:comments \"A structure to test SM with.\"))
  26.         (weight 0.0 :type float :computed nil :read-only t
  27.                 :comments \"The value of this slot will be computed.\")
  28.         (computed-weight 0.0 
  29.                          :type float 
  30.                          :computed t 
  31.                          :if-needed (lambda (i) (* 0.5 (test-weight (sm:gets 'test i))))
  32.                          :compiled-if-needed nil)
  33.         (nested-list nil :type list
  34.                      :comments \"This slot is to show how the print options work.\")
  35.         (comments \"\" :type string))")
  36. (sm:dst (test (:comments "A structure to test SM with."))
  37.         (weight 0.0 :type float :computed nil :read-only t
  38.                 :comments "The value of this slot will be computed.")
  39.         (computed-weight 0.0 
  40.                          :type float 
  41.                          :computed t 
  42.                          :if-needed (lambda (i) (* 0.5 (test-weight (sm:gets 'test i))))
  43.                          :compiled-if-needed nil)
  44.         (nested-list nil :type list 
  45.                      :comments "This slot is to show how the print options work.")
  46.         (comments "" :type string))
  47.  
  48. (format T "~%COMPUTED-SLOTS is (COMPUTED-WEIGHT):")
  49. (format T " ~S" (sm:computed-slots 'test))
  50. (format T "~%UNCOMPUTED-SLOTS is (WEIGHT NESTED-LIST COMMENTS):")
  51. (format T " ~S" (sm:uncomputed-slots 'test))
  52. (format T "~%READ-ONLY-SLOTS is (WEIGHT):")
  53. (format T " ~S" (sm:read-only-slots 'test))
  54. (format T "~%CREATOR is CREATE-TEST:")
  55. (format T " ~S" (sm:creator 'test))
  56. (format T "~%DEFINING-FORM:~%")
  57. (format T " ~S" (sm:defining-form 'test))
  58. (format T "~%TYPE-INFO:")
  59. (format T " ~S" (sm:type-info 'test))
  60. (format T "~%REUSABLE is NIL:")
  61. (format T " ~S" (sm:reusable 'test))
  62. (format T "~%SLOT-ACCESS is alist of names to access functions: ~%")
  63. (format T " ~S" (sm:slot-access 'test))
  64. (format T "~%SLOT-DEFAULTS is alist of names to default values: ~%")
  65. (format T " ~S" (sm:slot-defaults 'test))
  66. (format T "~%SLOT-INFO is alist of names to info: ~%")
  67. (format T " ~S" (sm:slot-info 'test))
  68. (format T "~%SLOT-TYPES is alist of names to allowed data types: ~%")
  69. (format T " ~S" (sm:slot-types 'test))
  70.  
  71. (format T "~%Creating a test instance:")
  72. (format T " ~S" 
  73.     (test t1 
  74.           :weight 0.5 
  75.           :nested-list (foo '#(0 1 2 3 4 5 6 7 8 9)
  76.                 (A (LONG LIST) fum ((far) foe) fazz fee fie foe fum english man blood)
  77.                 ("A string in the list")
  78.                 (sm::symbols sm::in sm::sm-package)
  79.                                 ((doo ((:these :are :keywords) dee)) dum) ha)
  80.               :comments "An instance to test TEST."))
  81.  
  82. (format T "~%Copying it to another instance:")
  83. (format T " ~S" (sm:copies 'test 't1 't2))
  84.  
  85. (format T "~%~%---------- PRINTING TESTS ----------")
  86. (format t "~%Printing NAME: ")
  87. (sm:prints 'test 't1 :style :name)
  88. (format t "~%Printing BRIEF:~%")
  89. (sm:prints 'test 't1 :style :brief)
  90. (format t "~%Printing SUMMARY:~%")
  91. (sm:prints 'test 't1 :style :summary)
  92. (format t "~%Printing PRETTY:~%")
  93. (sm:prints 'test 't1 :style :pretty)
  94. (format T "~%Check that the copied instance is the same:~%")
  95. (sm:prints 'test 't2 :style :pretty)
  96. (format t "~%Printing MACRO:~%")
  97. (sm:prints 'test 't1 :style :macro)
  98. (format t "~%Printing PRETTY-MACRO:~%")
  99. (sm:prints 'test 't1 :style :pretty-macro)
  100.  
  101.  
  102. (format T "~%~%---------- SLOT INFO TESTS ----------")
  103. (format T "~%Compiling the :if-needed method of TEST and saving it in its INFO list:")
  104. (format T " ~S"  
  105.         (setf (sm:slot-info 'test 'computed-weight :compiled-if-needed)
  106.               (compile nil (sm:slot-info 'test 'computed-weight :if-needed))))
  107.  
  108. (format T "~%Using the :compiled-if-needed to compute the computed-weight (0.25):")
  109. (format T " ~S"
  110.         (setf (test-computed-weight (sm:gets 'test 't1))
  111.               (funcall (sm:slot-info 'test 'computed-weight :compiled-if-needed)
  112.                        't1)))
  113.  
  114. (format T "~%~%---------- FREELIST TESTS ----------")
  115. (format T "~%Creating a reusable structure type:")
  116. (sm:dst (reusable-structure (:reusable t)
  117.                             (:comments "We reuse the memory of this one."))
  118.         slot1 slot2)
  119. (format t "~%Make instance R1 of REUSABLE-STRUCTURE:")
  120. (format T " ~S"
  121.         (reusable-structure r1 :slot1 "hi" :slot2 "there"))
  122. (format t "~%Instances now (R1):")
  123. (format T " ~S" (sm:instances 'reusable-structure))
  124. (format t "~%Destroy it:")
  125. (format T " ~S" (sm:destroys 'reusable-structure 'r1))
  126. (format t "~%Freelist of REUSABLE-STRUCTURE has a structure on it:")
  127. (format T " ~S"
  128.         (sm::structure-type-freelist (get 'reusable-structure 'sm::$structure-type$)))
  129. (format t "~%Make instance R2 of REUSABLE-STRUCTURE:")
  130. (format T " ~S"
  131.         (reusable-structure r2 :slot1 "another" :slot2 "go round"))
  132. (format t "~%Instances now (R2):" )
  133. (format T " ~S" (sm:instances 'reusable-structure))
  134. (format t "~%Freelist of REUSABLE-STRUCTURE now NIL:")
  135. (format T " ~S"
  136.         (sm::structure-type-freelist (get 'reusable-structure 'sm::$structure-type$)))
  137. (format T "~%Destroying al instances via RESET-TYPE:")
  138. (format T " ~S" (sm:reset-type 'reusable-structure))
  139. (format T "~%Flushing freelist of REUSABLE-STRUCTURE:")
  140. (format T " ~S" (sm:flush-freelist 'reusable-structure))
  141. (format t "~%Freelist of REUSABLE-STRUCTURE now NIL:")
  142. (format T " ~S"
  143.         (sm::structure-type-freelist (get 'reusable-structure 'sm::$structure-type$)))
  144.  
  145. (format T "~%~%---------- REDEFINING TESTS ----------")
  146. (setf sm:*warn-of-redefinitions* t)
  147. (format T "~%Redefining TEST with warnings on and:
  148. (sm:define-type  '(test (:redefine t) 
  149.                         (:comments \"A structure to test SM with.\"))
  150.         '(weight 1.0 :type float :computed nil :read-only nil)
  151.         '(computed-weight 0.0
  152.                          :type float 
  153.                          :computed t 
  154.                          :if-needed (lambda (i) (* 0.5 (test-weight (sm:gets 'test i))))
  155.                          :compiled-if-needed nil)
  156.         '(nested-list '((())) :type list :computed t)
  157.         '(comments \"New Test Comments\" :type string))")
  158. (sm:define-type  '(test (:redefine t)
  159.                         (:comments "A structure to test SM with."))
  160.         '(weight 1.0 :type float :computed nil :read-only nil)
  161.         '(computed-weight 0.0
  162.                          :type float 
  163.                          :computed t 
  164.                          :if-needed (lambda (i) (* 0.5 (test-weight (sm:gets 'test i))))
  165.                          :compiled-if-needed nil)
  166.         '(nested-list '((())) :type list :computed t)
  167.         '(comments "New Test Comments" :type string))
  168. (format T "~%Compare this reincarnation of T2 to its previous form:~%")
  169. (sm:prints 'test 't2 :style :pretty)
  170.  
  171. (format T "~%~%---------- FILE I/O TESTS ----------")
  172. (format T "~%Known types are (REUSABLE-TYPE TEST):")
  173. (format T " ~S" (sm:structure-types))
  174. (format T "~%Saving TEST type to a file, pretty-macro form with type definition:")
  175. (format T " ~S"
  176.         (sm:save-type 'test 
  177.                       :path "test.lisp" 
  178.                       :style :pretty-macro 
  179.                       :define-type t
  180.               :compile t))
  181. (format T "~%Destroying all types:" )
  182. (format T " ~S" (sm:destroy-all-types))
  183. (format T "~%Known types are (NIL):")
  184. (format T " ~S" (sm:structure-types))
  185. (format T "~%Loading file we just saved:")
  186. (format T " ~S" (sm:load-type 'test :path "test.lisp"))
  187. (format T "~%Known types are (TEST):")
  188. (format T " ~S" (sm:structure-types))
  189.  
  190. (format T "~%~%---------- EMBEDDED DEFINE-TYPE TEST ----------")
  191. (format T "~%First some background.
  192. If a DST is not at top level, then its PROGN expansion won't be either.
  193. On some machines, PROGN is treated differently when not at top 
  194. level. For expample, the HP preprocessor tries to expand SETFs 
  195. in the CREATE-<type> definition.  For :reusable types, there are
  196. SETFs to slot access functions defined in the DEFSTRUCT.  However,
  197. even though the DEFSTRUCT occurs before the CREATE-<type> in the 
  198. PROGN, it has not been evaluated yet (at preprocessor time).  The
  199. result is a 'no setf method known for <type>-<slot>' error.  On 
  200. such machines, DST can only occur at top level.  
  201.  
  202. In contrast, DEFINE-TYPE should be usable anywhere.  The following
  203. is a test of a DEFINE-TYPE no at top level, to ensure this is true.~%")
  204.  
  205. (format T "~%If this prints, it worked: you can put DEFINE-TYPE
  206. not at top level: ~S  But compile it to be sure!"
  207.         (sm:define-type '(not-top-level-test (:reusable t))
  208.                 '(slot1 nil :type list) 
  209.                 '(slot2 0.0 :type float)))
  210.  
  211. (format T "~%~%---------- END of TEST of SM----------
  212. Note: to be sure, try loading both lisp and compiled versions of this
  213. test, IN DIFFERENT LISP SESSIONS, so the second test does not rely on
  214. things defined in the first.~%")
  215.  
  216. ;;; EOF
  217.